# Time-stamp: <05 Dec 01 16:28:32 giron1>

=head1 NAME

GRAPH2PHONE - Grapheme to phoneme conversion package


=head1 SYNOPSIS

 use GRAPH2PHONE;

 my $list = new GRAPH2PHONE;
 $list->expandphono($head,$phone,$tail);
 ...

=head1 DESCRIPTION

This package contains some basic functionality for grapheme to phoneme
conversion.

=head1 AUTHOR

 $Id: GRAPH2PHONE.pm,v 1.1 2007/10/08 09:26:03 schweitz Exp $
 Franck Giron

=head1 LOG

 $Log: GRAPH2PHONE.pm,v $
 Revision 1.1  2007/10/08 09:26:03  schweitz
 version 2.4, lib vergessen

 Revision /main/8  5-Dec-2001.17:55:14  giron1
 Replaced the spaces for debugging by tabs and chop
 
 Revision 1.7  2001/07/24 16:19:48  giron1
 Improvement of parsing. Should now cope with bigger expression and many levels of
 parenthesis.

 Revision 1.6  2000/04/27 16:31:55  giron1
 Pod documentation updated


=cut

package GRAPH2PHONE;

#----------------------------------------------------------------------

=head1 FUNCTIONS

Here are the different available functions

=head2 new

phonetic expansion constructor

=cut

#----------------------------------------------------------------------

sub new{
  my $that = shift;
  my $class = ref($that) || $that;
  my $self = [];
  bless $self, $class;
  return $self;
}

my $sp = '';

#----------------------------------------------------------------------

=head2 checkpar($string)

check if parenthesis are in pairs in string

=cut

#----------------------------------------------------------------------
sub checkpar {
  my $listr = shift;
  my $string = shift;
  my $debug = 0;
  my $valid = 0;
  # return invalid for empty string
  if ($string ne '') {
    my @l  = split /[^()]*/, $string;
    my @lr = grep /\)/, @l;
    my @ll = grep /\(/, @l;
    if ($#lr == $#ll) {$valid = 1;}
    $debug and warn "$sp $#lr, $#ll, $valid\n";
  }
  return $valid;
}
#----------------------------------------------------------------------

=head2 expandphono

expands a phonetic description recursively

=cut

#----------------------------------------------------------------------
sub expandphono {
  my $listr = shift;
  my $ghead = shift;
  my $S = shift;
  my $gtail = shift;

  my $debug = 0;

  # don't change anything if there's nothing to do
  $S =~ s/\n//;
  my $result = $S;

  my $valid_small = 0;
  my $block_small = '';
  my $valid_big = 0;
  my $block_big = '';
  my $head = '';
  my $block = $S;
  my $tail = '';

  $debug and warn "\n${sp}EXPAND: $ghead: \"$block\" : $gtail.\n";

  # does block contains any parenthesis ?
  if ($block =~ m/[()]/) {

    # search for expressions containing parenthesis

    # matches a small block: ( "any character than ) or (" )
    if ( $block =~ m/\([^()]+\)/ ) {
      my $match_small = $&;
      my $head_small = $`;
      my $tail_small = $';
      $debug and warn "$sp small: $head_small, \"$match_small\", $tail_small.\n";
      $RLENGTH = length($match_small); $RSTART = length($head_small)+1;
      # generate the next block by suppressing first and last character
      # which should be ( and )
      $block_small = substr $block, $RSTART, $RLENGTH - 2;
      $valid_small = 1;
      $debug and warn "$sp check: \"$block_small\",$valid_small\n";
    }

    # matches the biggest parenthesis block
    if ( $block =~ m/\(.+\)/ ) {
      my $match_big = $&;
      my $head_big = $`;
      my $tail_big = $';
      $debug and warn "$sp big  : $head_big, \"$match_big\", $tail_big.\n";
      # check the parenthesis validity
      if ($listr->checkpar($match_big)) {
	$RLENGTH_BIG = length($match_big); $RSTART_BIG = length($head_big)+1;
	$block_big = substr $block, $RSTART_BIG, $RLENGTH_BIG - 2;
      } else {
	die "Error in expression: $block, check your parenthesis syntax !";
      }
      # check the resulting block validity
      # it should contain no open parenthesis
      # or it should contain only a string chain separated with |
      $_ = $block_big;
      if (m/^[^\)]*\(.+\)[^\(]*$/ or (not m/[()]/ and m/|/) ) {$valid_big = 1;}

      if ($valid_big) {$RSTART = $RSTART_BIG; $RLENGTH = $RLENGTH_BIG;}
      $debug and warn "$sp check: \"$block_big\",$valid_big\n";
    }

    $debug and warn "$sp RSTART=$RSTART, RLENGTH=$RLENGTH\n";
    
    # At least one block should be valid
    if ($valid_big or $valid_small) {

      # Extracting head and tail
      $head  = substr $block, 0, $RSTART - 1;
      $tail  = substr $block, $RSTART + $RLENGTH - 1, 999999;

      # Takes the big valid block or the small one if not valid
      $block = ($valid_big) ? $block_big : $block_small;

      $debug and warn "$sp ghead>$ghead.\thead>$head.\tblock>$block.\ttail>$tail.\tgtail>$gtail.\n";
       
      $debug and $sp .= "\t";

      if ($ghead eq '' and $gtail eq '') {
	$listr->expandphono($head,$block,$tail);
      } else {
	$listr->expandphono($ghead.'('.$head,$block,$tail.')'.$gtail);
      }
      $debug and chop $sp;
    }
  }
  # block has no parenthesis anymore
  else {
    $debug and warn "$sp ghead:$ghead.\thead:$head.\tblock:$block.\ttail:$tail.\tgtail:$gtail\n";
    $debug and warn "$sp BLOCK:$block\n";

    if ( $block ne '|') {
      my @alternative = ();
      for (my $i=0;$i < (@alternative = split(/\|/,$block,9999)); $i++) {
	$debug and warn "$sp $i \"$alternative[$i]\"\n";
	$result = $ghead . $alternative[$i] . $gtail;

	if ($result =~ m/[()|]/ ) {
	  $debug and $sp .= "\t";
	  $debug and warn "$sp >Expand: $result.\n\n";
	  $listr->expandphono('',$result,"");
	  $debug and chop $sp;
	} else {
	  $debug and warn "$sp RETURN2: $result.\n\n";
	  push @{$listr}, $result;
	}
      }
    }
  }
}





#----------------------------------------------------------------------

=head2 printexp

print the expansion of a list

=cut

#----------------------------------------------------------------------

sub printexp{
  my $listr = shift;

  # Create the final expression
  my $exp = '';

  foreach (@$listr) {
    $exp .= '['. $_ . ']<|>';
  }

  if ($#{$listr} > 1) {
    $exp =~ s/\<\|\>$/\<\)\>/;
    $exp = '<(>' . $exp;
  } else {
    $exp =~ s/\<\|\>$//;
  }

  # And print it to stdout
  print "$exp";
}

#----------------------------------------------------------------------

=head2 treat_liaison

treats the liaisons in a list of successive words

=cut

#----------------------------------------------------------------------

sub treat_liaison {
  my ($listr) = shift;
  my $debug = 0;
  my ($i,$word);

  # Add a dummy entry at the end of the list
  # to treat also final liaisons
  my $elistr = [''];
  push @$listr, $elistr;

  # Performs liaison checking for each element
  for ($i=0;$i<$#{$listr};$i++) {
    $debug and warn "$i before: @{$listr->[$i]}\n";
    my @flist = ();
    foreach $word (@{$listr->[$i]}) {
      # Check words containing a liaison
      if ($word =~ m/\#V/) {
	my $liaison = 0;
	# Treat words ending with a liaison by looking the
	# start letter of the following word
	if ($word =~ m/\#V$/) {
	  foreach (@{$listr->[$i+1]}) {$liaison |= m/^[aAeEiIoOuUy269@]/;}
	} else {
	  # words with liaison inside
	  $liaison = $word =~ m/\#V[aAeEiIoOuUy269@]/;
	}
	if ($liaison) {push @flist, $word;}
      } else {push @flist, $word;}
    }
    # Replaces previous list with final one
    @{$listr->[$i]} = @flist;
    $debug and warn  "$i after: @{$listr->[$i]}\n\n";
  }
  $debug and warn "@{$listr->[$#{$listr}]}\n";
}

#----------------------------------------------------------------------

=head2 expand_transcription ($fh)

this function expands an already existing transcription file given by
its filehandle

=cut

#----------------------------------------------------------------------

sub expand_transcription {
  my $listr = shift;
  my $fh = shift;
  my $debug = 0;
  # Expand each entry
  while (<$fh>) {
    chop;
    # suppresses each < > [ and ]
    s/[<>\[\]]//g;
    next if ("$_" eq '');
    # expands phonetic expressions
    my $tlist = new GRAPH2PHONE;
    $tlist->expandphono('',$_,'');
    $debug and warn join(',',@$tlist), "\n";
    push @$listr, $tlist unless ($#{$tlist}<0);
  }
}

1;
